Power Programmierung/Power-Programmierung (Tewi)(1994).iso/magazine/drdobbs/1991/10/xalloc.asc

Text File | 1991-09-10 | 8KB | 354 lines

_XALLOC: AN EXPANDED MEMORY MANAGER FOR TURBO PASCAL_
by Herbert Gintis

[LISTING ONE]

unit xlineobj;

{ Typical use:
        program xtest;
        uses xalloc,xlineobj;
        var
            s : xline;
        begin
            if not xalloc_init then halt;
            s.init;
            s.put_text('This goes into expanded memory');
            writeln(s.get_text);
            s.done;
            xalloc_done;
        end.
}
interface

uses xalloc;

type
    xline = object
        len : byte;
        mem : xaddress;
        constructor init;
        destructor done; virtual;
        procedure newsize(ncols : integer);
        function get_text : string;
        procedure put_text(s : string);
    end;

implementation

var
    xs : ^string;

constructor xline.init;
const
    mincols = 8;
begin
    xgetmem(mem,mincols);
    len := mincols-1;
    xs := xpage_in(mem);
    xs^ := '';
end;

destructor xline.done;
begin
    xfreemem(mem,len+1);
end;

procedure xline.newsize(ncols : integer);
begin
    xfreemem(mem,len+1);
    xgetmem(mem,ncols+1);
    xs := xpage_in(mem);
    len := ncols;
end;

function xline.get_text : string;
begin
    xs := xpage_in(mem);
    get_text := xs^;
end;

procedure xline.put_text(s : string);
begin
    if length(s) <> len then newsize(length(s));
    xs := xpage_in(mem);
    xs^ := s;
end;

end.




[LISTING TWO]

unit xalloc;
    {-See the unit xlineobj.pas for typical use of this unit}
interface

const
    nilpage = $ff;
type
    xaddress = record
        page : byte;
        pos : word;
    end;
function xalloc_init : boolean;
procedure xgetmem(var x : xaddress;size : word);
procedure xfreemem(var x : xaddress;size : word);
function xpage_in(var x : xaddress) : pointer;
function xmaxavail : longint;
function xmemavail : longint;
procedure xalloc_done;

implementation

uses crt,dos;

const
    emm_int = $67;
    dos_int = $21;
    maxfreeblock = 4000;
    xblocksize = $4000;
    _get_frame = $41;
    _unalloc_count = $42;
    _alloc_pages = $43;
    _map_page = $44;
    _dealloc_pages = $45;
    _change_alloc = $51;
type
    xheap = array[0..1000] of word;
    fblock = record
        page : byte;
        start,stop : word;
    end;
    fblockarray = array[1..maxfreeblock] of fblock;
var
    regs : registers;
    handle,tot_pages : word;
    xheapptr : ^xheap;
    xfreeptr : ^fblockarray;
    last_page,lastptr : integer;
    map : array[0..3] of integer;
    frame : word;

function ems_installed : boolean;
const
    device_name : string[8] = 'EMMXXXX0';
var
    i : integer;
begin
    ems_installed := false;
    with regs do begin  {check for ems present}
        ah := $35;  {get code segment pointed to by interrupt 67h}
        al := emm_int;
        intr(dos_int,regs);
    for i := 1 to 8 do if device_name[i] <> chr(mem[es : i + 9]) then exit;
    end;
    ems_installed := true;
end;

function unalloc_count(var available : word): boolean;
begin
    with regs do begin
        ah := _unalloc_count;
        intr(emm_int,regs);
        available := bx;
        unalloc_count := ah = 0  {return the error code}
    end;
end;

function alloc_pages(needed: integer): boolean;
begin
    with regs do begin
        ah := _alloc_pages;
        bx := needed;
        intr(emm_int,regs);
        handle := dx;
        alloc_pages := (ah = 0);        {return the error code}
    end;
end;

function xdealloc_pages: boolean;
begin
    with regs do begin
        ah := _dealloc_pages;
        dx := handle;
        intr(emm_int,regs);
        xdealloc_pages := (ah = 0);  {return the error code}
    end;
end;

function change_alloc(needed : integer) : boolean;
begin
    with regs do begin
        ah := _change_alloc;
        bx := needed;
        dx := handle;
        intr(emm_int,regs);
        change_alloc := (ah = 0);    {return the error code}
    end;
end;

function xmap_page(l_page,p_page: integer): boolean;
begin
    xmap_page := true;
    if map[p_page] <> l_page then with regs do begin
        ah := _map_page;
        al := p_page;
        bx := l_page;
        dx := handle;
        intr(emm_int,regs);
        xmap_page := (ah = 0);
        if ah = 0 then map[p_page] := l_page;
    end;
end;

function xpage_in(var x : xaddress) : pointer;
begin
    if xmap_page(x.page,0) then xpage_in := ptr(frame,x.pos)
    else xpage_in := nil;
end;

function xget_frame(var frame: word): boolean;
begin
    with regs do begin
        ah := _get_frame;
        intr(emm_int,regs);
        frame := bx;
        xget_frame := (ah = 0); {return the error code}
    end;
end;

procedure xgetmem(var x : xaddress;size : word);
var
    i : integer;
begin
    for i := 1 to lastptr do begin
        with xfreeptr^[i] do begin
            if size <= stop - start then begin
                x.page := page;
                x.pos := start;
                inc(start,size);
                if start = stop then begin
                    xfreeptr^[i] := xfreeptr^[lastptr];
                    dec(lastptr);
                end;
                exit;
            end;
        end;
    end;
    x.page := nilpage;
    i := 0;
    repeat
        inc(i);
        if i > tot_pages then exit;
        if i > last_page then begin
            inc(last_page);
            if not change_alloc(last_page) then exit;
        end;
    until xblocksize - xheapptr^[pred(i)] > size;
    with x do begin
        page := pred(i);
        pos := xheapptr^[page];
        inc(xheapptr^[page],size);
    end;
end;

procedure xfreemem(var x : xaddress;size : word);
var
    i,xstop : integer;
begin
    xstop := x.pos + size;
    i := 0;
    while i < lastptr do begin
        inc(i);
        with xfreeptr^[i] do begin
            if x.page = page then begin
                if x.pos >= start then begin
                    if x.pos <= stop then begin
                    x.pos := start;
                    if xstop < stop then xstop := stop;
                    xfreeptr^[i] := xfreeptr^[lastptr];
                    dec(lastptr);
                    dec(i)
                    end;
                end
                else if xstop >= start then begin
                    if xstop < stop then xstop := stop;
                    xfreeptr^[i] := xfreeptr^[lastptr];
                    dec(lastptr);
                    dec(i)
                end;
            end;
        end;
    end;
    if lastptr > 0 then with xfreeptr^[lastptr] do
        if start = stop then dec(lastptr);
    if x.pos < xstop then begin
        if xstop = xheapptr^[x.page] then xheapptr^[x.page] := x.pos
        else begin
            if lastptr < maxfreeblock then begin
                inc(lastptr);
                with xfreeptr^[lastptr] do begin
                    page := x.page;
                    start := x.pos;
                    stop := xstop;
                end;
            end;
        end;
    end;
end;

function xmemavail : longint;
var
    s : longint;
    i : integer;
begin
    s := 0;
    for i := 0 to pred(tot_pages) do inc(s,$4000 - xheapptr^[i]);
    for i := 1 to lastptr do with xfreeptr^[i] do inc(s,stop - start);
    xmemavail := s;
end;

function xmaxavail : longint;
var
    s : longint;
    i : integer;
begin
    s := 0;
    for i := 0 to pred(tot_pages) do
        if $4000 - xheapptr^[i] > s then s := $4000 - xheapptr^[i];
    for i := 1 to lastptr do with xfreeptr^[i] do
        if stop - start > s then s := stop - start;
    xmaxavail := s;
end;

procedure xalloc_done;
begin
    if not xdealloc_pages then;
end;

function xalloc_init : boolean;
var
    i : word;
begin
    xalloc_init := false;
    if not ems_installed then exit;
    if not unalloc_count(tot_pages) then exit;
    if tot_pages = 0 then exit;
    if not xget_frame(frame) then exit;
    getmem(xheapptr,tot_pages*sizeof(word));
    if xheapptr = nil then exit;
    new(xfreeptr);
    if xfreeptr = nil then exit;
    for i := 0 to pred(tot_pages) do xheapptr^[i] := 0;
    if not alloc_pages(1) then exit;
    xalloc_init := true;
    lastptr := 0;
    last_page := 1;
    for i := 0 to 3 do map[i] := -1;
end;

end.